Methods

library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)
library(brms)

df <- read.csv("data/data.csv") |>
  mutate(
    Date = lubridate::dmy(Date),
    Participant = fct_reorder(Participant, Date),
    Screen_Refresh = as.character(Screen_Refresh),
    Education = fct_relevel(Education, "Doctorate", "Master", "Bachelor", "High School", "Other", "Prefer not to Say"),
    Belief = fct_relevel(Belief, "Fake", "Real"),
    Stimulus_Interest = case_when(
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Opposite" ~ TRUE,
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Same" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Opposite" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Same" ~ TRUE,
      Sexual_Orientation %in% c("Bisexual", "Queer") ~ TRUE,
      TRUE ~ NA
    )
  )


# head(df[is.na(df$Stimulus_Attract), ])

# Create individual scores for Simulation Monitoring
df <- df |>
  group_by(Participant, Belief) |>
  summarise(
    Confidence = mean(abs(Belief_Confidence)),
    n = n() / 109
  ) |>
  pivot_wider(names_from = "Belief", values_from = c("Confidence", "n")) |>
  ungroup() |>
  merge(df, by = "Participant")

Exclusions

outliers <- c(
  # Very short duration for questionnaire in particular + low rating correlations
  "5eaef8702b68455d6e130595_ptsga",
  "5f0f0a2a8b2a480447f31b21_lqgpz",
  "611d03b822d4c8e041ea0c32_m0knb"
)
outliers_partial <- c(
  "5dc3485219ca0326027ce91f_37ho9",
  "5c6414540821d30001046198_x9q7r",
  "60dd7b03f1e72d38230df476_9yh9n",
  "5962799cb752840001ca478b_jh4sl",
  "5f44c23fbf2ddb80bcdf0edc_dnbny",
  "5e80370d48b5f47170e30e5c_5w2gf"
)

We removed 3 participants based on failed attention checks.

Extreme Items

extreme_items <- df |>
  group_by(Stimulus, Belief) |>
  summarize(n = n() / length(unique(df$Participant))) |>
  pivot_wider(values_from = "n", names_from = "Belief") |>
  mutate(File = paste0("experiment/stimuli/AMFD/", Stimulus)) |>
  arrange(Real) |>
  filter(Real < 0.15 | Real > 0.85)


p_item <- df |>
  filter(Stimulus %in% extreme_items$Stimulus) |>
  mutate(Stimulus = fct_relevel(Stimulus, as.character(extreme_items$Stimulus))) |>
  ggplot(aes(x = Belief_Answer, y = Stimulus, fill = Stimulus)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups") +
  geom_vline(xintercept = 0, linetype = "dotted") +
  ggimage::geom_image(data = extreme_items, aes(image = File, x = 0, y = Stimulus), size = 0.1, by = "height") +
  # scale_y_discrete(expand = c(0.5, 0.5)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-1, 0, 1),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d(option = "inferno") +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    # axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )
# p_item


df <- df |>
  filter(!Stimulus %in% extreme_items$Stimulus)

extreme_items
## # A tibble: 1 × 4
## # Groups:   Stimulus [1]
##   Stimulus     Fake  Real File                               
##   <chr>       <dbl> <dbl> <chr>                              
## 1 NF-1071.jpg 0.874 0.126 experiment/stimuli/AMFD/NF-1071.jpg

We removed 1 trials per participant.

Attention Checks and Duration

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, starts_with("Attention"), starts_with("Duration"), n_Fake) |>
  slice(1) |>
  ungroup() |>
  rowwise() |>
  mutate(Attention_Check = mean(c(Attention_Check1, Attention_Check2, Attention_Check3))) |>
  ungroup() |>
  arrange(Attention_Check)

Ratings

dfsub$r_Trustworthy <- NA
dfsub$r_Attractive <- NA
dfsub$r_Beauty <- NA
for (participant in dfsub$Participant) {
  dfsub[dfsub$Participant == participant, "r_Trustworthy"] <- cor(df[df$Participant == participant, "Trustworthy"], df[df$Participant == participant, "Norms_Trustworthy"])
  dfsub[dfsub$Participant == participant, "r_Attractive"] <- cor(df[df$Participant == participant, "Attractive"], df[df$Participant == participant, "Norms_Attractive"])
  dfsub[dfsub$Participant == participant, "r_Beauty"] <- cor(df[df$Participant == participant, "Beauty"], df[df$Participant == participant, "Norms_Attractive"])
}

Summary

data.frame(Participant = c(paste0("Total (n=", nrow(dfsub), ")")), t(sapply(dfsub[2:ncol(dfsub)], mean, na.rm = TRUE))) |>
  rbind(dfsub) |>
  mutate(Attention_Check = paste0(
    insight::format_value(Attention_Check, 1),
    " (", insight::format_value(Attention_Check1, 1),
    ", ",
    insight::format_value(Attention_Check2, 1),
    ", ",
    insight::format_value(Attention_Check3, 1),
    ")"
  )) |>
  select(-Attention_Check1, -Attention_Check2, -Attention_Check3) |>
  datawizard::data_relocate("Attention_Check", 2) |>
  knitr::kable() |>
  kableExtra::row_spec(1, italic = TRUE) |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers) + 1, background = "#EF9A9A") |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers_partial) + 1, background = "#FFCC80")  |> 
  kableExtra::kable_styling(full_width = TRUE) |> 
  kableExtra::scroll_box(width = "100%", height = "500px")
Participant Attention_Check Duration_Questionnaires Duration_Task n_Fake r_Trustworthy r_Attractive r_Beauty
Total (n=103) 1.0 (1.0, 1.0, 1.0) 12.09 23.7 0.445 0.268 0.442 0.465
611d03b822d4c8e041ea0c32_m0knb 0.6 (0.6, 0.4, 0.6) 6.00 20.5 0.248 0.164 0.208 0.225
5f0f0a2a8b2a480447f31b21_lqgpz 0.6 (0.2, 1.0, 0.5) 164.70 17.6 0.642 -0.144 0.343 0.288
5962799cb752840001ca478b_jh4sl 0.7 (1.0, 0.2, 1.0) 19.93 30.4 0.284 0.063 0.344 0.326
5dc3485219ca0326027ce91f_37ho9 0.8 (0.5, 1.0, 1.0) 7.01 16.1 0.587 0.253 0.572 0.557
5c6414540821d30001046198_x9q7r 0.9 (1.0, 1.0, 0.6) 9.84 23.4 0.284 0.330 0.483 0.466
60dd7b03f1e72d38230df476_9yh9n 0.9 (0.6, 1.0, 1.0) 12.86 19.9 0.092 0.435 0.429 0.550
5f44c23fbf2ddb80bcdf0edc_dnbny 0.9 (0.7, 1.0, 1.0) 4.71 24.8 0.486 0.103 0.147 0.195
5e80370d48b5f47170e30e5c_5w2gf 0.9 (0.7, 1.0, 1.0) 5.64 22.8 0.440 0.350 0.604 0.612
5fb7cfde7808523cea8ee891_xlrlw 1.0 (0.9, 1.0, 1.0) 6.95 17.7 0.514 0.324 0.515 0.532
613e4bf960ca68f8de00e5e7_cfsdt 1.0 (0.9, 1.0, 1.0) 11.15 23.8 0.468 0.265 0.466 0.428
6115d9fa61078b29b8db91ff_ewn8c 1.0 (0.9, 1.0, 1.0) 11.06 19.3 0.440 0.452 0.250 0.341
5f1acd8cb55680224c3d452a_56nun 1.0 (0.9, 1.0, 1.0) 11.66 26.0 0.642 0.383 0.527 0.518
5b8646582c180900019c9eb7_xt3l6 1.0 (1.0, 1.0, 1.0) 20.16 21.4 0.514 0.308 0.363 0.338
5d936374253d0a0017f32d96_n98qu 1.0 (1.0, 1.0, 1.0) 6.87 13.3 0.440 0.233 0.455 0.457
611b86fe4bd6db6f42e4afea_4asue 1.0 (1.0, 1.0, 1.0) 17.36 36.8 0.330 0.421 0.279 0.365
5f233d7f53212b0e22bf055d_x9368 1.0 (1.0, 1.0, 1.0) 13.32 16.7 0.624 0.430 0.603 0.619
5fb015142942a535524f55fc_u1vq2 1.0 (1.0, 1.0, 1.0) 14.47 18.4 0.624 0.428 0.575 0.598
5d7f8ffae664ab001967d9d3_7mrcg 1.0 (1.0, 1.0, 1.0) 4.83 11.5 0.468 0.306 0.209 0.361
613a92a2dbedc6e7aad89199_thehb 1.0 (1.0, 1.0, 1.0) 10.85 40.0 0.541 0.305 0.462 0.456
5ad63c167f70c10001904bc5_ers7p 1.0 (1.0, 1.0, 1.0) 12.18 25.6 0.413 0.298 0.466 0.521
5bb511c6689fc5000149c703_d9k0p 1.0 (1.0, 1.0, 1.0) 12.56 21.8 0.083 0.405 -0.168 0.351
5d40a12f4994c40001e4b80c_2ytoa 1.0 (1.0, 1.0, 1.0) 13.25 21.8 0.587 0.338 0.609 0.521
5eaef8702b68455d6e130595_ptsga 1.0 (1.0, 1.0, 1.0) 2.69 14.9 0.523 0.021 0.091 0.096
5eb17f5f5b4ec12749a65a24_cmop5 1.0 (1.0, 1.0, 1.0) 11.40 18.9 0.450 0.358 0.362 0.514
5ed8e10d54fe053fbc756c72_zknp4 1.0 (1.0, 1.0, 1.0) 7.63 26.3 0.468 -0.056 0.540 0.444
5f034ecf38c5aa527d056830_2pvm9 1.0 (1.0, 1.0, 1.0) 10.09 19.0 0.339 0.274 0.564 0.539
5f3801b18c88962be7831304_ubcua 1.0 (1.0, 1.0, 1.0) 8.73 16.8 0.330 0.153 0.578 0.558
5faa6cab8ac7a937a5240fcb_xsbot 1.0 (1.0, 1.0, 1.0) 10.20 14.9 0.505 0.153 0.544 0.517
601941db6605160008690742_twd28 1.0 (1.0, 1.0, 1.0) 6.25 13.9 0.578 0.299 0.453 0.444
6036ab8b13ac9c79d7e67e81_ln8ep 1.0 (1.0, 1.0, 1.0) 7.14 13.4 0.651 0.273 0.265 0.312
60a256f83ef6ada5debc47a9_q7wl4 1.0 (1.0, 1.0, 1.0) 6.03 16.0 0.321 0.218 0.520 0.451
60a3a03bc01ba594c9cca88d_v0jdv 1.0 (1.0, 1.0, 1.0) 11.76 30.0 0.495 0.406 0.258 0.410
60b6c415dbda3236ea22455a_dmezs 1.0 (1.0, 1.0, 1.0) 24.73 43.0 0.450 0.263 0.628 0.613
60e1eb72b81681d6c856bd7b_uzbeq 1.0 (1.0, 1.0, 1.0) 8.62 20.8 0.706 0.439 0.631 0.435
60e4b1dcd0eedab1e11019d1_4varz 1.0 (1.0, 1.0, 1.0) 8.61 33.0 0.349 0.191 0.368 0.388
60f3261b934093c881b85cf6_lnoph 1.0 (1.0, 1.0, 1.0) 13.37 27.8 0.450 0.225 0.520 0.575
611b1c9ce8ad1ac6db791065_hwlhj 1.0 (1.0, 1.0, 1.0) 8.57 26.1 0.541 0.364 0.231 0.525
613a972033d79df11a6570de_1u773 1.0 (1.0, 1.0, 1.0) 14.71 26.2 0.450 0.209 0.666 0.635
613baa22050360ec21d4437f_9sac0 1.0 (1.0, 1.0, 1.0) 16.64 17.6 0.688 0.106 0.195 0.178
614f681bacfa57e3d06529ad_qv0u7 1.0 (1.0, 1.0, 1.0) 15.65 30.0 0.404 0.256 0.427 0.417
6160f3629ac70cba36523ff8_zslcv 1.0 (1.0, 1.0, 1.0) 9.14 23.4 0.523 0.366 0.416 0.444
5c00043a6d931200019bcb9b_wnj27 1.0 (1.0, 1.0, 1.0) 20.36 34.7 0.284 0.543 0.582 0.634
5d3f63a92df9f7001bd92a32_oj5t7 1.0 (1.0, 1.0, 1.0) 7.93 20.1 0.523 0.193 0.390 0.431
5db9b910001ffa0188426dca_knhee 1.0 (1.0, 1.0, 1.0) 6.05 25.5 0.596 0.134 0.169 0.148
5ecd37ee75736a068808fa6c_v4ej4 1.0 (1.0, 1.0, 1.0) 10.52 16.0 0.468 0.217 0.612 0.536
5fdfd04b9bf07d83b2e5f780_gtb9u 1.0 (1.0, 1.0, 1.0) 9.30 20.6 0.147 0.222 0.657 0.620
6107133e49bf8db00bd6d389_qkj9f 1.0 (1.0, 1.0, 1.0) 11.38 29.6 0.477 0.366 0.299 0.579
613a69d8ed1c11f70b3d37c7_yu0z2 1.0 (1.0, 1.0, 1.0) 11.16 28.9 0.477 0.235 0.372 0.415
6146385561e8f95ff4f3b5d6_cvm6o 1.0 (1.0, 1.0, 1.0) 9.13 24.9 0.642 0.197 0.405 0.346
614b55e22ff3944a165736bb_cl98h 1.0 (1.0, 1.0, 1.0) 14.66 22.6 0.450 0.441 0.580 0.514
616cb46402d68cdfc6e8c8db_xzyj4 1.0 (1.0, 1.0, 1.0) 4.59 25.4 0.211 0.000 0.217 0.188
6294ce94ea81c4554b141010_u5v5t 1.0 (1.0, 1.0, 1.0) 8.28 18.7 0.339 0.294 0.491 0.461
558fa9dffdf99b7ce2924662_58ffp 1.0 (1.0, 1.0, 1.0) 10.06 34.9 0.624 0.314 0.451 0.470
572b96ba3ab9df000dbb4461_bq660 1.0 (1.0, 1.0, 1.0) 14.16 16.5 0.202 0.059 0.513 0.540
57b8e70f35624400013d690c_boeew 1.0 (1.0, 1.0, 1.0) 5.71 19.7 0.440 0.402 0.550 0.589
59501095c58c85000101dc57_od0ny 1.0 (1.0, 1.0, 1.0) 5.81 26.6 0.541 0.377 0.495 0.458
595bd5c85ae9a80001ce3426_32tr4 1.0 (1.0, 1.0, 1.0) 8.43 19.4 0.413 0.259 0.477 0.549
5a7875355292b80001227f63_uh6o3 1.0 (1.0, 1.0, 1.0) 11.53 24.4 0.450 0.399 0.513 0.474
5baf6705848bbd0001d6fc8a_kahs0 1.0 (1.0, 1.0, 1.0) 12.03 32.5 0.486 0.266 0.482 0.531
5c573e54e9813700018acc31_kv5lw 1.0 (1.0, 1.0, 1.0) 6.72 23.6 0.514 0.342 0.415 0.396
5dbd7193e8add82b72d795f2_8g8wk 1.0 (1.0, 1.0, 1.0) 11.12 22.9 0.266 0.461 0.577 0.624
5de476f9b5b7ff447db5c4aa_chlcj 1.0 (1.0, 1.0, 1.0) 10.25 17.6 0.468 0.307 0.514 0.459
5e7bcff00fb32c0f51fea882_bvbwo 1.0 (1.0, 1.0, 1.0) 15.14 19.2 0.229 0.207 0.485 0.490
5e8dddaf3d1b57068b77b2f2_8ebal 1.0 (1.0, 1.0, 1.0) 12.53 32.1 0.404 0.507 0.540 0.636
5eb170206e577a07e9954c65_csm2p 1.0 (1.0, 1.0, 1.0) 15.61 23.0 0.459 0.477 0.688 0.718
5ece75528f582a08555e0a3e_21ckq 1.0 (1.0, 1.0, 1.0) 13.74 48.5 0.523 0.453 0.500 0.613
5ef0a866cd9cde0fcd0d2f77_rvy90 1.0 (1.0, 1.0, 1.0) 10.57 26.2 0.532 0.200 0.599 0.597
5f09068244f84c18faaa74bc_q0ukp 1.0 (1.0, 1.0, 1.0) 6.97 19.3 0.450 -0.031 0.467 0.496
5f108dea719866356702d26f_p836j 1.0 (1.0, 1.0, 1.0) 5.29 17.4 0.422 -0.226 0.413 0.422
5f49424d243bb347aaec4897_ggzqw 1.0 (1.0, 1.0, 1.0) 8.61 25.3 0.303 0.434 0.518 0.475
5f5e7de4c81d3672642cd612_hpyto 1.0 (1.0, 1.0, 1.0) 7.09 19.1 0.532 0.269 0.524 0.300
5f600669b846780f0fe45709_erd2u 1.0 (1.0, 1.0, 1.0) 13.40 31.0 0.514 0.310 0.587 0.645
5f761e5106b786071f45b4aa_78zle 1.0 (1.0, 1.0, 1.0) 11.56 27.8 0.385 0.048 0.207 0.219
5f7ebad5cf009c196fd54b2b_d68uh 1.0 (1.0, 1.0, 1.0) 8.39 15.6 0.495 0.404 0.674 0.659
5f97e6601f6d0e016087fc91_h6pvt 1.0 (1.0, 1.0, 1.0) 4.71 26.9 0.239 0.051 0.166 0.289
5f9aba6600cdf11f1c9b915c_cakh2 1.0 (1.0, 1.0, 1.0) 26.74 46.8 0.394 0.266 0.325 0.357
5fb633dfaeda3f0aa05eefad_4t92s 1.0 (1.0, 1.0, 1.0) 8.18 18.1 0.505 0.289 0.521 0.499
5ff4a242cbe069bc27d9278b_relyq 1.0 (1.0, 1.0, 1.0) 6.51 14.0 0.183 0.225 0.572 0.540
603f6e643234e512fc197ae1_vowxj 1.0 (1.0, 1.0, 1.0) 11.40 32.7 0.486 0.304 0.538 0.281
6045cb37ffdadc70e734a73b_ns96q 1.0 (1.0, 1.0, 1.0) 17.87 52.2 0.541 0.448 0.427 0.429
604b169fe4b7991ec08da3a6_9o72l 1.0 (1.0, 1.0, 1.0) 7.21 23.4 0.330 0.111 0.456 0.419
605a1c7fe0ca143242990e95_528pg 1.0 (1.0, 1.0, 1.0) 13.97 23.1 0.560 0.388 0.491 0.526
6081728972120aa7f9685791_aqvhb 1.0 (1.0, 1.0, 1.0) 25.43 41.3 0.578 0.312 0.494 0.573
6099df8e57bf74dbc121c774_5jnsc 1.0 (1.0, 1.0, 1.0) 6.22 26.6 0.459 0.510 0.502 0.512
60a6ba026f8bd75b67b23c97_z458q 1.0 (1.0, 1.0, 1.0) 11.75 14.6 0.596 0.241 0.475 0.518
60b8b5dcb46db8ae98d0b047_4u9jy 1.0 (1.0, 1.0, 1.0) 4.86 21.4 0.367 0.151 -0.220 0.445
60cefa69352cbf2549f2bf35_as90e 1.0 (1.0, 1.0, 1.0) 8.50 19.2 0.486 0.513 0.539 0.520
60ddfb3db6a71ad9ba75e387_u85bv 1.0 (1.0, 1.0, 1.0) 8.48 14.7 0.550 0.068 0.502 0.435
61081aab1dad0a92827a371d_bbpfc 1.0 (1.0, 1.0, 1.0) 8.87 21.6 0.486 0.285 0.561 0.532
61093d97f7bf8a4f8117eb82_yzsmx 1.0 (1.0, 1.0, 1.0) 13.15 24.5 0.550 0.122 0.259 0.316
610d97bf0ee9babdb89986ea_3t039 1.0 (1.0, 1.0, 1.0) 8.71 20.4 0.450 0.527 0.584 0.556
61253683f41abc76c81ec082_xc4uu 1.0 (1.0, 1.0, 1.0) 7.45 19.6 0.294 0.346 0.559 0.546
612ba6c594a6d54154a88ae7_m0duf 1.0 (1.0, 1.0, 1.0) 6.73 12.5 0.339 0.513 0.508 0.445
61330f324c6c15a907dc2706_zg72v 1.0 (1.0, 1.0, 1.0) 9.53 28.0 0.404 0.252 0.432 0.495
613af39692992acbacdbbbbc_0g94n 1.0 (1.0, 1.0, 1.0) 17.26 39.3 0.394 0.112 0.458 0.518
6151a21b24b1ef1bc130b97d_cazbl 1.0 (1.0, 1.0, 1.0) 14.07 24.8 0.615 0.050 0.371 0.359
61545919a17f1331cb7b33a7_mszfq 1.0 (1.0, 1.0, 1.0) 12.28 20.4 0.018 0.182 0.359 0.376
61687ebcd2a35ffb762d1928_0hgcq 1.0 (1.0, 1.0, 1.0) 13.01 40.4 0.413 0.299 0.496 0.557
616e5ae706e970fe0aff99b6_561t0 1.0 (1.0, 1.0, 1.0) 6.15 25.2 0.624 0.453 0.548 0.497
6266a4e5846e1e41812a0432_ds50m 1.0 (1.0, 1.0, 1.0) 6.33 16.5 0.477 0.201 0.502 0.488
62e416f154e4c9e7f39d5cf7_2a9nx 1.0 (1.0, 1.0, 1.0) 6.52 9.3 0.468 0.089 0.434 0.443
5ec554706960444f4a1768de_uma91 1.0 (1.0, 1.0, 1.0) 8.58 16.4 0.248 -0.142 0.188 0.513
610aa32712b5d159232e01ca_2qade 1.0 (1.0, 1.0, 1.0) 6.85 20.9 0.523 0.403 0.548 0.556
# kableExtra::row_spec(which(str_detect(dfsub$Participant, "613a972033d79df11a6570de")) + 1, background = "green")
p_att <- dfsub |>
  select(Participant, starts_with("Att")) |>
  pivot_longer(-Participant) |>
  # mutate(name = str_remove(name, "Cor_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  scale_color_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Score", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_time <- dfsub |>
  select(Participant, starts_with("Duration")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "Duration_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#4CAF50", "#FF9800")) +
  scale_color_manual(values = c("#4CAF50", "#FF9800")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Duration (min)", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_cor <- dfsub |>
  select(Participant, starts_with("r_")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "r_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  scale_color_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(
      angle = 45, hjust = 1,
      color = ifelse(levels(dfsub$Participant) %in% outliers, "red", ifelse(levels(dfsub$Participant) %in% outliers_partial, "orange", "black"))
    ),
    legend.position = "top"
  ) +
  labs(y = "Correlation", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

(p_att + theme(axis.text.x = element_blank())) /
  (p_time + theme(axis.text.x = element_blank())) /
  (p_cor)


df <- df |>
  filter(!Participant %in% outliers)

Participants

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, Age, Sex, Sexual_Orientation, Ethnicity, Education, Nationality, Device_OS, starts_with("Screen"), starts_with("IPIP"), starts_with("Social_"), starts_with("FFNI_"), starts_with("GPTS_"), starts_with("IUS_"), starts_with("SelfAttractiveness"), starts_with("AI"), n_Real, Confidence_Fake, Confidence_Real) |>
  slice(1) |>
  ungroup()

The final sample included 100 participants (Mean age = 27.9, SD = 8.5, range: [19, 66]; Sex: 48.0% females, 52.0% males, 0.0% other; Education: Doctorate, 2.00%; Master, 18.00%; Bachelor, 34.00%; High School, 40.00%; Other, 5.00%; Prefer not to Say, 1.00%).

plot_distribution <- function(dfsub, what = "Age", title = what, subtitle = "", fill = "orange") {
  dfsub |>
    ggplot(aes_string(x = what)) +
    geom_density(fill = fill) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0)) +
    ggtitle(title, subtitle = subtitle) +
    theme_modern() +
    theme(
      plot.title = element_text(face = "bold", hjust = 0.5),
      plot.subtitle = element_text(face = "italic", hjust = 0.5),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
}

plot_waffle <- function(dfsub, what = "Nationality", title = what, rows = 10, size = 6) {
  # library(emojifont)
  ggwaffle::waffle_iron(dfsub, what, rows = rows) |>
    # mutate(label = emojifont::fontawesome('fa-smiley')) |>
    # mutate(label = emojifont::emoji('smiley')) |>
    ggplot(aes(x, y)) +
    geom_point(aes(color = group), shape = "square", size = size) +
    # ggwaffle::geom_waffle(color = "white") +
    # geom_point() +
    # geom_text(aes(color=group ,label=label), family='fontawesome-webfont', size=4) +
    # geom_text(aes(color=group ,label=label), family='EmojiOne', size=4) +
    coord_equal() +
    ggtitle(title) +
    labs(fill = "", color = "") +
    # scale_x_continuous(expand = c(0, 0)) +
    # scale_y_continuous(expand = c(0, 0)) +
    theme_void() +
    # ggwaffle::theme_waffle() +
    theme(plot.title = element_text(face = "bold", hjust = 0.5))
}
p1 <- estimate_density(dfsub$Age) |>
  ggplot(aes(x = x, y = y)) +
  geom_area(fill = "#FF9800") +
  labs(x = "Age", y = "") +
  theme_modern()

p2 <- plot_waffle(dfsub, "Sex") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63", "Other" = "#FF9800"))

p3 <- plot_waffle(dfsub, "Sexual_Orientation")


p4 <- plot_waffle(dfsub, "Education") +
  scale_fill_viridis_d()

p5 <- dfsub |>
  group_by(Nationality) |>
  mutate(n = n()) |>
  ungroup() |>
  mutate(Nationality = fct_reorder(Nationality, desc(n))) |>
  ggplot(aes(Nationality)) +
  geom_bar(aes(fill = Nationality)) +
  scale_fill_viridis_d(guide = "none") + 
  theme_modern() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) 

p6 <- plot_waffle(dfsub, "Ethnicity") +
  scale_fill_manual(values = c("Latino" = "#FF5722", "Asian" = "#FF9800", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Jewish" = "#9C27B0", "Mixed" = "#795548"))

p7 <- plot_waffle(dfsub, "Screen_Resolution", title = "Screen Resolution") +
  scale_fill_pizza_d() +
  guides(fill = "none")

p8 <- plot_waffle(dfsub, "Device_OS", title = "Device OS") +
  scale_fill_bluebrown_d()

# p10 <- plot_waffle(dfsub, "Screen_Refresh") +
#   scale_fill_viridis_d()

patchwork::wrap_plots(list(p1, p2, p3, p5, p4, p6))

Results

Manipulation Check

Real / Fake

# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
  mutate(Participant = fct_relevel(Participant, df |>
    group_by(Participant) |>
    summarize(Belief_Answer = mean(Belief_Answer)) |>
    ungroup() |>
    arrange(Belief_Answer) |>
    pull(Participant) |>
    as.character())) |>
  # mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
  ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
  geom_vline(xintercept = 0, linetype = "dotted") +
  scale_y_discrete(expand = c(0.02, 0)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-0.95, 0, 0.95),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d() +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "grey", color = "white") +
  ggside::scale_xsidey_continuous(expand = c(0, 0))



df |> 
  group_by(Participant, Belief) |> 
  summarize(n = n() / 108, 
            Confidence = mean(Belief_Confidence)) |> 
  pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |> 
  ungroup() |> 
  describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
## 
## Parameter       | Mean |       95% CI
## -------------------------------------
## n_Fake          | 0.44 | [0.11, 0.64]
## n_Real          | 0.56 | [0.36, 0.89]
## Confidence_Fake | 0.61 | [0.24, 1.00]
## Confidence_Real | 0.61 | [0.25, 0.99]


m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.105
## Stimulus    | 0.087

Colinearity

IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")

correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
## 
## Parameter1  |  Parameter2 |    r |        95% CI | t(10798) |         p
## -----------------------------------------------------------------------
## Attractive  |      Beauty | 0.68 | [ 0.67, 0.69] |    97.16 | < .001***
## Attractive  | Trustworthy | 0.06 | [ 0.04, 0.08] |     6.08 | < .001***
## Attractive  |    Familiar | 0.13 | [ 0.11, 0.15] |    13.35 | < .001***
## Beauty      | Trustworthy | 0.26 | [ 0.24, 0.28] |    28.10 | < .001***
## Beauty      |    Familiar | 0.01 | [-0.01, 0.03] |     1.37 | 0.171    
## Trustworthy |    Familiar | 0.05 | [ 0.03, 0.06] |     4.80 | < .001***
## 
## p-value adjustment method: Holm (1979)
## Observations: 10800
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
  for (y in IVs) {
    if (x == y) next
    print(paste(y, "~", x))
    model <- glmmTMB::glmmTMB(as.formula(
      paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
    ),
    data = df,
    family = glmmTMB::beta_family()
    )

    # model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
    #                     random = list(Participant=~1, Stimulus=~1),
    #                     data = df,
    #                     family=mgcv::betar())

    pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
    pred$y <- y
    pred <- data_rename(pred, x, "Score")
    pred$x <- x
    preds <- rbind(preds, pred)

    dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
  }
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"

dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
  ggplot(aes(x = Score, y = Predicted)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  # geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
  geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
  scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
  scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  facet_grid(y ~ x, switch = "both") +
  theme_modern() +
  labs(title = "Collinearity in the Stimuli Ratings") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggnewscale::new_scale_fill() +
  scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")

Effect of Delay

model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
  data = df,
  family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)

m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
  data = df,
  family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
  mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))


df |>
  ggplot(aes(x = Delay, y = Real)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  geom_hline(yintercept = 0.5, linetype = "dotted") +
  # geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
  geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = pred, aes(y = Predicted), color = "red") +
  scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  theme_modern() +
  labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "#795548", color = "white") +
  ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")


hdi(df$Delay)
## 95% HDI: [1.58, 30.31]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
## 
## Delay | Participant | Stimulus | Predicted |   SE |       95% CI
## ----------------------------------------------------------------
## 0.00  |             |          |      0.60 | 0.02 | [0.55, 0.64]
## 60.00 |             |          |      0.50 | 0.04 | [0.42, 0.58]
## 
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)

parameters::parameters(model, effects="fixed", exponentiate=TRUE) |> 
  display()
Fixed Effects
Parameter Odds Ratio SE 95% CI z p
(Intercept) 1.48 0.15 (1.22, 1.79) 3.94 < .001
Delay 0.99 2.89e-03 (0.99, 1.00) -2.27 0.023
parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.82 0.11 (0.60, 1.04) 7.39 < .001
Belief (Real) 7.73e-03 0.08 (-0.15, 0.17) 0.09 0.926
Belief (Fake) * Delay 1.16e-04 3.03e-03 (-5.82e-03, 6.05e-03) 0.04 0.969
Belief (Real) * Delay -5.95e-03 2.62e-03 (-0.01, -8.18e-04) -2.27 0.023

Determinants of Reality

make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
  # Models
  m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
    data = df,
    family = "binomial"
  )
  y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
  # gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
  #                  data=df,
  #                  algorithm="sampling",
  #                  family = "bernoulli")
  # trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
  # slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
  # trend$Trend <- interpret_pd(slope$pd)
  # trend$group <- 0
  # trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))


  m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
    data = df,
    family = glmmTMB::beta_family()
  )
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  param <- parameters::parameters(m_real, effects = "fixed", keep = var)
  sig1 <- data.frame(x = 0.5, 
                     y = y_real[c(11, 31), "Predicted"] + c(0.04, -0.05),
                     p = c(min(param$p[c(1, 3)]), min(param$p[c(2, 4)])),
                     Sex = y_real[c(11, 31), "Sex"])
  sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
  param <- parameters::parameters(m_conf, effects = "fixed", keep = var)
  sig2 <- data.frame(x = 0.5,
                     y = y_conf[c(11, 31, 51, 71), "Predicted"] + c(0.04, -0.04, -0.04, 0.04),
                     p = c(min(param$p[c(1, 5)]), min(param$p[c(2, 6)]), min(param$p[c(3, 7)]), min(param$p[c(4, 8)])),
                     Belief = y_conf[c(11, 31, 51, 71), "Belief"],
                     Sex = y_conf[c(11, 32, 51, 72), "Sex"])
  sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
  
  
  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
    scale_fill_gradientn(colors = c("white", fill), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    # geom_point2(alpha = 0.25, size = 4, color = "black") +
    geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
    geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
    geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
    # geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
    # geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
    geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
    geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
    scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fill, color = "white") +
    ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
  var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
  var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
  var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
  var = "Familiar", fill = "#2196F3"
)

Attractiveness

parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Attractive, 2)1 1.00 3.64 (-6.13, 8.13) 0.28 0.783
Sex (Male) * poly(Attractive, 2)1 16.37 4.39 (7.76, 24.98) 3.73 < .001
Sex (Female) * poly(Attractive, 2)2 7.77 3.25 (1.41, 14.13) 2.40 0.017
Sex (Male) * poly(Attractive, 2)2 4.61 5.22 (-5.61, 14.83) 0.88 0.377
performance::performance(rez_at$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.20 0.03
performance::icc(rez_at$model_belief, by_group = TRUE)  |> 
  display()
Group ICC
Participant 0.09
Stimulus 0.09
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive")  |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Attractive, 2)1 0.98 2.59 (-4.09, 6.06) 0.38 0.704
Belief (Real) * SexFemale * poly(Attractive, 2)1 2.13 1.87 (-1.54, 5.81) 1.14 0.255
Belief (Fake) * SexMale * poly(Attractive, 2)1 2.65 3.41 (-4.02, 9.33) 0.78 0.436
Belief (Real) * SexMale * poly(Attractive, 2)1 0.78 2.64 (-4.39, 5.94) 0.30 0.768
Belief (Fake) * SexFemale * poly(Attractive, 2)2 3.35 2.33 (-1.21, 7.92) 1.44 0.150
Belief (Real) * SexFemale * poly(Attractive, 2)2 4.38 1.74 (0.96, 7.79) 2.51 0.012
Belief (Fake) * SexMale * poly(Attractive, 2)2 -8.85 4.57 (-17.81, 0.11) -1.94 0.053
Belief (Real) * SexMale * poly(Attractive, 2)2 5.11 2.77 (-0.32, 10.53) 1.85 0.065

rez_at$p

Beauty

parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Beauty, 2)1 -1.14 3.68 (-8.36, 6.08) -0.31 0.757
Sex (Male) * poly(Beauty, 2)1 9.54 4.14 (1.43, 17.65) 2.31 0.021
Sex (Female) * poly(Beauty, 2)2 3.43 3.31 (-3.05, 9.91) 1.04 0.300
Sex (Male) * poly(Beauty, 2)2 7.46 4.43 (-1.23, 16.14) 1.68 0.092
performance::performance(rez_gl$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.20 0.03
performance::icc(rez_gl$model_belief, by_group = TRUE)|> 
  display()
Group ICC
Participant 0.10
Stimulus 0.08
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Beauty, 2)1 -2.08 2.46 (-6.90, 2.73) -0.85 0.397
Belief (Real) * SexFemale * poly(Beauty, 2)1 2.41 2.01 (-1.52, 6.34) 1.20 0.229
Belief (Fake) * SexMale * poly(Beauty, 2)1 -1.89 3.27 (-8.31, 4.52) -0.58 0.563
Belief (Real) * SexMale * poly(Beauty, 2)1 2.02 2.38 (-2.65, 6.69) 0.85 0.397
Belief (Fake) * SexFemale * poly(Beauty, 2)2 6.61 2.36 (1.98, 11.24) 2.80 0.005
Belief (Real) * SexFemale * poly(Beauty, 2)2 2.66 1.96 (-1.18, 6.50) 1.36 0.175
Belief (Fake) * SexMale * poly(Beauty, 2)2 -5.50 3.34 (-12.04, 1.05) -1.65 0.100
Belief (Real) * SexMale * poly(Beauty, 2)2 4.43 2.47 (-0.41, 9.26) 1.79 0.073

rez_gl$p

Trustworthiness

parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Trustworthy, 2)1 11.60 3.80 (4.15, 19.06) 3.05 0.002
Sex (Male) * poly(Trustworthy, 2)1 6.29 3.81 (-1.18, 13.76) 1.65 0.099
Sex (Female) * poly(Trustworthy, 2)2 -0.12 3.93 (-7.83, 7.59) -0.03 0.975
Sex (Male) * poly(Trustworthy, 2)2 0.33 3.99 (-7.49, 8.16) 0.08 0.933
performance::performance(rez_tr$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.19 0.03
performance::icc(rez_tr$model_belief, by_group = TRUE) |> 
  display()
Group ICC
Participant 0.09
Stimulus 0.07
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Trustworthy, 2)1 2.05 2.46 (-2.77, 6.86) 0.83 0.405
Belief (Real) * SexFemale * poly(Trustworthy, 2)1 1.27 2.54 (-3.70, 6.24) 0.50 0.616
Belief (Fake) * SexMale * poly(Trustworthy, 2)1 -3.10 2.81 (-8.61, 2.41) -1.10 0.270
Belief (Real) * SexMale * poly(Trustworthy, 2)1 0.43 2.24 (-3.97, 4.82) 0.19 0.849
Belief (Fake) * SexFemale * poly(Trustworthy, 2)2 1.27 2.64 (-3.90, 6.44) 0.48 0.629
Belief (Real) * SexFemale * poly(Trustworthy, 2)2 6.47 2.42 (1.73, 11.21) 2.68 0.007
Belief (Fake) * SexMale * poly(Trustworthy, 2)2 -3.89 2.81 (-9.41, 1.63) -1.38 0.167
Belief (Real) * SexMale * poly(Trustworthy, 2)2 0.55 2.32 (-4.00, 5.11) 0.24 0.812

rez_tr$p

Familiarity

parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * poly(Familiar, 2)1 2.81 3.99 (-5.02, 10.63) 0.70 0.482
Sex (Male) * poly(Familiar, 2)1 7.95 5.05 (-1.95, 17.85) 1.57 0.116
Sex (Female) * poly(Familiar, 2)2 -2.22 3.70 (-9.47, 5.04) -0.60 0.549
Sex (Male) * poly(Familiar, 2)2 -1.03 4.72 (-10.29, 8.23) -0.22 0.827
performance::performance(rez_fa$model_belief, metrics = c("R2")) |> 
  display()
R2 (cond.) R2 (marg.)
0.20 0.03
performance::icc(rez_fa$model_belief, by_group = TRUE) |> 
  display()
Group ICC
Participant 0.10
Stimulus 0.07
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
Belief (Fake) * SexFemale * poly(Familiar, 2)1 4.77 2.64 (-0.40, 9.95) 1.81 0.071
Belief (Real) * SexFemale * poly(Familiar, 2)1 -1.35 2.09 (-5.44, 2.75) -0.65 0.518
Belief (Fake) * SexMale * poly(Familiar, 2)1 -12.67 3.67 (-19.87, -5.47) -3.45 < .001
Belief (Real) * SexMale * poly(Familiar, 2)1 9.31 2.99 (3.45, 15.17) 3.11 0.002
Belief (Fake) * SexFemale * poly(Familiar, 2)2 0.44 2.46 (-4.37, 5.25) 0.18 0.859
Belief (Real) * SexFemale * poly(Familiar, 2)2 -0.63 2.13 (-4.81, 3.56) -0.29 0.769
Belief (Fake) * SexMale * poly(Familiar, 2)2 8.14 4.15 (6.32e-03, 16.28) 1.96 0.050
Belief (Real) * SexMale * poly(Familiar, 2)2 -1.42 2.67 (-6.64, 3.81) -0.53 0.595

rez_fa$p

Interaction with Self-Attractiveness

cor_test(dfsub, "SelfAttractiveness1", "SelfAttractiveness2")
## Parameter1          |          Parameter2 |    r |       95% CI | t(98) |         p
## -----------------------------------------------------------------------------------
## SelfAttractiveness1 | SelfAttractiveness2 | 0.88 | [0.82, 0.92] | 18.19 | < .001***
## 
## Observations: 100

df$Self_Attractiveness <- rowMeans(df[c("SelfAttractiveness1", "SelfAttractiveness2")])
m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Attractive, 2) * Self_Attractiveness) + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * Self Attractiveness 1.32 0.96 (-0.56, 3.21) 1.38 0.169
Sex (Male) * Self Attractiveness -2.21 1.64 (-5.42, 1.00) -1.35 0.178
Sex (Female) * poly(Attractive, 2)1 * Self Attractiveness -22.26 21.07 (-63.56, 19.04) -1.06 0.291
Sex (Male) * poly(Attractive, 2)1 * Self Attractiveness 32.32 33.75 (-33.83, 98.46) 0.96 0.338
Sex (Female) * poly(Attractive, 2)2 * Self Attractiveness 12.20 14.19 (-15.61, 40.01) 0.86 0.390
Sex (Male) * poly(Attractive, 2)2 * Self Attractiveness -14.63 32.37 (-78.07, 48.80) -0.45 0.651


m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Beauty, 2) * Self_Attractiveness) + Trustworthy + Familiar + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
Sex (Female) * Self Attractiveness 1.33 1.07 (-0.76, 3.42) 1.25 0.213
Sex (Male) * Self Attractiveness -1.79 1.76 (-5.25, 1.67) -1.01 0.310
Sex (Female) * poly(Beauty, 2)1 * Self Attractiveness -27.38 15.75 (-58.25, 3.49) -1.74 0.082
Sex (Male) * poly(Beauty, 2)1 * Self Attractiveness 45.72 29.04 (-11.20, 102.63) 1.57 0.115
Sex (Female) * poly(Beauty, 2)2 * Self Attractiveness 8.97 13.20 (-16.90, 34.84) 0.68 0.497
Sex (Male) * poly(Beauty, 2)2 * Self Attractiveness -6.85 29.41 (-64.50, 50.80) -0.23 0.816

Inter-Individual Correlates

plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
  y_real <- estimate_relation(m_real, at = c(var), length = 21)
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
  
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
  sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
                     p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
  sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
  sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
                     p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
                     Belief = y_conf[c(11, 31), "Belief"])
  sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
  
  # Data
  dat <- insight::get_data(m_conf) |> 
                  group_by(Participant, Belief) |> 
                  data_select(c("Participant", "Belief", var, "Belief_Confidence")) |> 
                  mean_qi(.width = 0.5) |> 
    mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
  
  
  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
    scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
    ggnewscale::new_scale_fill() +
    stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
    scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
    geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
    geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
    geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
    geom_line(data = y_real, aes(y = Predicted), size=1) +
    geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
    geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
    scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
    scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
    ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  p
}
make_correlation <- function(x, y) {
  cor <- correlation::correlation(x,
    y,
    bayesian = TRUE,
    bayesian_prior = "medium.narrow",
    sort = TRUE
  ) |>
    datawizard::data_remove(c("ROPE_Percentage"))
  cor$`BF (Spearman)` <- format_bf(
    correlation::correlation(
      x, y,
      bayesian = TRUE,
      ranktransform = TRUE,
      bayesian_prior = "medium.narrow"
    )$BF,
    name = NULL, stars = TRUE
  )
  cor |>
    arrange(desc(BF))
}

IPIP-6

f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.04 0.63 (-1.20, 1.27) 0.06 0.955
IPIP6 Extraversion 3.86e-03 0.36 (-0.69, 0.70) 0.01 0.991
IPIP6 Conscientiousness 2.19e-03 0.38 (-0.74, 0.75) 5.78e-03 0.995
IPIP6 Neuroticism -0.02 0.40 (-0.80, 0.77) -0.04 0.965
IPIP6 Openness 0.31 0.41 (-0.49, 1.11) 0.76 0.445
IPIP6 HonestyHumility -0.50 0.37 (-1.21, 0.22) -1.35 0.177
IPIP6 Agreeableness 0.38 0.46 (-0.51, 1.28) 0.84 0.399


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) -0.36 0.92 (-2.17, 1.45) -0.39 0.695
Belief (Real) 0.20 0.20 (-0.20, 0.60) 1.00 0.318
Belief (Fake) * IPIP6 Extraversion -0.24 0.52 (-1.26, 0.78) -0.47 0.642
Belief (Real) * IPIP6 Extraversion -0.39 0.52 (-1.41, 0.63) -0.76 0.449
Belief (Fake) * IPIP6 Conscientiousness 0.47 0.56 (-0.62, 1.55) 0.84 0.403
Belief (Real) * IPIP6 Conscientiousness 0.82 0.55 (-0.26, 1.91) 1.49 0.137
Belief (Fake) * IPIP6 Neuroticism 0.15 0.59 (-1.00, 1.30) 0.26 0.796
Belief (Real) * IPIP6 Neuroticism 0.34 0.58 (-0.80, 1.49) 0.59 0.555
Belief (Fake) * IPIP6 Openness 1.03 0.59 (-0.13, 2.20) 1.73 0.083
Belief (Real) * IPIP6 Openness 0.64 0.59 (-0.52, 1.80) 1.07 0.283
Belief (Fake) * IPIP6 HonestyHumility -1.02 0.54 (-2.07, 0.03) -1.90 0.058
Belief (Real) * IPIP6 HonestyHumility -1.69 0.54 (-2.74, -0.63) -3.14 0.002
Belief (Fake) * IPIP6 Agreeableness 1.05 0.67 (-0.26, 2.36) 1.58 0.115
Belief (Real) * IPIP6 Agreeableness 1.10 0.67 (-0.21, 2.40) 1.65 0.099

p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip

sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |            Parameter2 |   rho |         95% CI |      pd |               Prior |    BF | BF (Spearman)
## ------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.21 | [-0.38, -0.01] | 98.70%* | Beta (5.20 +- 5.20) | 3.57* |         3.55*
## Confidence_Fake |        IPIP6_Openness |  0.17 | [-0.01,  0.34] |  96.20% | Beta (5.20 +- 5.20) |  1.40 |          1.12
## 
## Observations: 100

Narcissism

f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) -0.07 0.47 (-0.99, 0.85) -0.14 0.887
FFNI AcclaimSeeking 0.87 0.46 (-0.04, 1.78) 1.88 0.060
FFNI Arrogance 5.98e-03 0.41 (-0.80, 0.81) 0.01 0.988
FFNI Authoritativeness 0.11 0.40 (-0.67, 0.89) 0.28 0.782
FFNI Distrust 0.21 0.38 (-0.54, 0.95) 0.54 0.590
FFNI Entitlement -0.15 0.44 (-1.01, 0.71) -0.35 0.730
FFNI Exhibitionism 0.24 0.38 (-0.51, 0.98) 0.62 0.536
FFNI Exploitativeness -0.15 0.38 (-0.91, 0.60) -0.40 0.687
FFNI GrandioseFantasies -0.17 0.34 (-0.83, 0.50) -0.49 0.627
FFNI Indifference -0.13 0.39 (-0.89, 0.63) -0.34 0.733
FFNI LackOfEmpathy 0.54 0.40 (-0.25, 1.33) 1.34 0.180
FFNI Manipulativeness -0.76 0.43 (-1.60, 0.08) -1.78 0.075
FFNI NeedForAdmiration -0.35 0.41 (-1.16, 0.46) -0.84 0.402
FFNI ReactiveAnger 0.52 0.35 (-0.16, 1.20) 1.51 0.131
FFNI Shame -0.21 0.45 (-1.09, 0.66) -0.48 0.632
FFNI ThrillSeeking -0.09 0.30 (-0.67, 0.49) -0.29 0.768


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.55 0.67 (-0.76, 1.85) 0.82 0.410
Belief (Real) -0.78 0.16 (-1.09, -0.46) -4.86 < .001
Belief (Fake) * FFNI AcclaimSeeking 1.60 0.66 (0.30, 2.90) 2.42 0.016
Belief (Real) * FFNI AcclaimSeeking 2.08 0.66 (0.79, 3.37) 3.16 0.002
Belief (Fake) * FFNI Arrogance -0.02 0.59 (-1.17, 1.14) -0.03 0.976
Belief (Real) * FFNI Arrogance -0.39 0.59 (-1.54, 0.75) -0.67 0.501
Belief (Fake) * FFNI Authoritativeness -1.23 0.57 (-2.35, -0.11) -2.15 0.032
Belief (Real) * FFNI Authoritativeness -1.38 0.57 (-2.50, -0.27) -2.43 0.015
Belief (Fake) * FFNI Distrust 0.19 0.55 (-0.88, 1.26) 0.35 0.727
Belief (Real) * FFNI Distrust 0.66 0.54 (-0.41, 1.73) 1.21 0.226
Belief (Fake) * FFNI Entitlement -0.32 0.63 (-1.55, 0.91) -0.51 0.612
Belief (Real) * FFNI Entitlement 0.42 0.63 (-0.81, 1.64) 0.67 0.502
Belief (Fake) * FFNI Exhibitionism 0.07 0.55 (-1.00, 1.14) 0.13 0.898
Belief (Real) * FFNI Exhibitionism 0.04 0.54 (-1.02, 1.11) 0.08 0.937
Belief (Fake) * FFNI Exploitativeness -0.21 0.55 (-1.29, 0.87) -0.38 0.704
Belief (Real) * FFNI Exploitativeness -0.15 0.55 (-1.23, 0.92) -0.28 0.779
Belief (Fake) * FFNI GrandioseFantasies 0.75 0.49 (-0.21, 1.71) 1.54 0.124
Belief (Real) * FFNI GrandioseFantasies 0.39 0.49 (-0.56, 1.34) 0.80 0.424
Belief (Fake) * FFNI Indifference -0.02 0.56 (-1.12, 1.07) -0.04 0.965
Belief (Real) * FFNI Indifference -0.04 0.55 (-1.12, 1.05) -0.06 0.948
Belief (Fake) * FFNI LackOfEmpathy -0.12 0.58 (-1.26, 1.01) -0.21 0.831
Belief (Real) * FFNI LackOfEmpathy 0.10 0.57 (-1.03, 1.23) 0.17 0.863
Belief (Fake) * FFNI Manipulativeness 0.37 0.61 (-0.83, 1.57) 0.60 0.550
Belief (Real) * FFNI Manipulativeness 0.25 0.61 (-0.95, 1.44) 0.41 0.684
Belief (Fake) * FFNI NeedForAdmiration -0.05 0.59 (-1.21, 1.11) -0.09 0.928
Belief (Real) * FFNI NeedForAdmiration 0.06 0.59 (-1.09, 1.22) 0.11 0.913
Belief (Fake) * FFNI ReactiveAnger 0.96 0.50 (-0.02, 1.93) 1.92 0.054
Belief (Real) * FFNI ReactiveAnger 0.75 0.49 (-0.22, 1.71) 1.51 0.132
Belief (Fake) * FFNI Shame -0.90 0.64 (-2.15, 0.36) -1.40 0.161
Belief (Real) * FFNI Shame -0.69 0.64 (-1.93, 0.56) -1.08 0.280
Belief (Fake) * FFNI ThrillSeeking -1.03 0.42 (-1.87, -0.20) -2.44 0.015
Belief (Real) * FFNI ThrillSeeking -0.93 0.42 (-1.75, -0.10) -2.20 0.028

p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1


p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF9800") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2


p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_ThrillSeeking", fill = "#FF5722") + labs(x = "Narcissism (Thrill Seeking)")
p_ffni3 

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |              Parameter2 |  rho |        95% CI |       pd |               Prior |      BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real |     FFNI_AcclaimSeeking | 0.26 | [ 0.09, 0.44] | 99.83%** | Beta (5.20 +- 5.20) | 14.38** |      53.44***
## Confidence_Fake |     FFNI_AcclaimSeeking | 0.22 | [ 0.05, 0.39] | 99.12%** | Beta (5.20 +- 5.20) |   4.52* |         6.26*
## Confidence_Real | FFNI_GrandioseFantasies | 0.22 | [ 0.03, 0.39] |  98.60%* | Beta (5.20 +- 5.20) |   4.18* |         6.07*
## n_Real          |     FFNI_AcclaimSeeking | 0.19 | [ 0.02, 0.37] |  97.95%* | Beta (5.20 +- 5.20) |    2.21 |          2.78
## Confidence_Fake | FFNI_GrandioseFantasies | 0.18 | [ 0.00, 0.36] |  97.05%* | Beta (5.20 +- 5.20) |    1.93 |          1.33
## Confidence_Real |      FFNI_ReactiveAnger | 0.15 | [-0.03, 0.33] |   94.58% | Beta (5.20 +- 5.20) |    1.12 |          1.92
## Confidence_Fake |   FFNI_Manipulativeness | 0.15 | [-0.04, 0.32] |   94.12% | Beta (5.20 +- 5.20) |    1.04 |         0.776
## 
## Observations: 100

Social Anxiety

f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.34 0.16 (0.03, 0.66) 2.15 0.032
Social Anxiety 0.90 0.51 (-0.10, 1.90) 1.77 0.076
Social Phobia -0.97 0.45 (-1.86, -0.08) -2.14 0.033


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.95 0.23 (0.50, 1.41) 4.10 < .001
Belief (Real) -0.21 0.05 (-0.31, -0.12) -4.33 < .001
Belief (Fake) * Social Anxiety -0.24 0.79 (-1.79, 1.31) -0.30 0.761
Belief (Real) * Social Anxiety 0.36 0.79 (-1.19, 1.90) 0.45 0.651
Belief (Fake) * Social Phobia 0.10 0.70 (-1.28, 1.48) 0.14 0.886
Belief (Real) * Social Phobia -0.32 0.70 (-1.69, 1.06) -0.45 0.650

p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
p_social 

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)

Intolerance to Uncertainty

f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.40 0.27 (-0.14, 0.94) 1.47 0.142
IUS ProspectiveAnxiety 5.24e-03 0.51 (-1.00, 1.01) 0.01 0.992
IUS InhibitoryAnxiety -0.24 0.39 (-1.00, 0.52) -0.62 0.534


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.74 0.40 (-0.05, 1.53) 1.84 0.066
Belief (Real) -0.35 0.09 (-0.52, -0.17) -3.91 < .001
Belief (Fake) * IUS ProspectiveAnxiety 0.83 0.77 (-0.68, 2.34) 1.07 0.284
Belief (Real) * IUS ProspectiveAnxiety 1.10 0.77 (-0.40, 2.61) 1.43 0.151
Belief (Fake) * IUS InhibitoryAnxiety -0.78 0.58 (-1.92, 0.37) -1.33 0.183
Belief (Real) * IUS InhibitoryAnxiety -0.74 0.58 (-1.88, 0.40) -1.27 0.204
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)

Paranoid Beliefs

f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "), 
            ") + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.32 0.14 (0.04, 0.60) 2.22 0.027
GPTS Reference -0.61 0.44 (-1.47, 0.25) -1.39 0.165
GPTS Persecution 0.72 0.41 (-0.10, 1.53) 1.73 0.084


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 1.05 0.20 (0.65, 1.45) 5.16 < .001
Belief (Real) -0.27 0.04 (-0.36, -0.19) -6.36 < .001
Belief (Fake) * GPTS Reference -0.66 0.68 (-1.99, 0.66) -0.98 0.327
Belief (Real) * GPTS Reference -0.33 0.68 (-1.66, 0.99) -0.49 0.622
Belief (Fake) * GPTS Persecution 0.35 0.64 (-0.90, 1.60) 0.55 0.582
Belief (Real) * GPTS Persecution 0.35 0.63 (-0.89, 1.59) 0.55 0.580
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)

AI

rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)


efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
## 
## Variable              |  MR1  |    MR2    |    MR3    | Complexity | Uniqueness
## -------------------------------------------------------------------------------
## AI_4_DailyLife        | 0.88  |   0.07    |   0.15    |    1.07    |    0.20   
## AI_8_Exciting         | 0.79  |   0.20    |   0.14    |    1.20    |    0.31   
## AI_9_Applications     | 0.79  |   0.09    |   0.17    |    1.12    |    0.34   
## AI_7_RealisticVideos  | 0.14  |   0.74    | -4.43e-03 |    1.07    |    0.43   
## AI_5_ImitatingReality | 0.29  |   0.63    |   0.05    |    1.42    |    0.52   
## AI_3_VideosReal       | -0.15 |   0.50    |   -0.12   |    1.30    |    0.71   
## AI_1_RealisticImages  | 0.18  |   0.49    |   0.19    |    1.56    |    0.69   
## AI_2_Unethical        | 0.18  | -7.70e-04 |   0.78    |    1.11    |    0.35   
## AI_6_Dangerous        | 0.17  |   -0.12   |   0.62    |    1.23    |    0.57   
## AI_10_FaceErrors      | 0.02  |   0.07    |   0.25    |    1.14    |    0.93   
## 
## The 3 latent factors (varimax rotation) accounted for 49.60% of the total variance of the original data (MR1 = 22.50%, MR2 = 15.19%, MR3 = 11.91%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
  cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |> 
  cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")


m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")

parameters::parameters(m_real, effects="fixed") |> 
  display()
Fixed Effects
Parameter Log-Odds SE 95% CI z p
(Intercept) 0.29 0.09 (0.12, 0.47) 3.31 < .001
AI Enthusiasm 7.40e-03 0.07 (-0.13, 0.15) 0.10 0.919
AI Realness 0.05 0.08 (-0.11, 0.20) 0.61 0.545
AI Danger 0.16 0.08 (-2.03e-03, 0.31) 1.93 0.053


m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)), 
                           data=df, 
                           family = glmmTMB::beta_family())

parameters::parameters(m_conf, effects="fixed") |> 
  display()
Fixed Effects
Parameter Coefficient SE 95% CI z p
(Intercept) 0.90 0.10 (0.71, 1.10) 9.11 < .001
Belief (Real) -0.15 0.02 (-0.20, -0.11) -6.87 < .001
Belief (Fake) * AI Enthusiasm 0.38 0.11 (0.18, 0.59) 3.60 < .001
Belief (Real) * AI Enthusiasm 0.29 0.11 (0.08, 0.50) 2.74 0.006
Belief (Fake) * AI Realness -6.44e-03 0.12 (-0.23, 0.22) -0.06 0.956
Belief (Real) * AI Realness 0.04 0.12 (-0.18, 0.27) 0.38 0.702
Belief (Fake) * AI Danger -0.17 0.12 (-0.41, 0.06) -1.46 0.143
Belief (Real) * AI Danger -0.09 0.12 (-0.32, 0.14) -0.75 0.453


p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") + 
  labs(x = "Enthusiasm about AI technology")
p_ai 

r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |    Parameter2 |   rho |         95% CI |       pd |               Prior |      BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm |  0.28 | [ 0.09,  0.43] | 99.83%** | Beta (5.20 +- 5.20) | 23.04** |      37.85***
## Confidence_Real | AI_Enthusiasm |  0.24 | [ 0.05,  0.41] | 99.55%** | Beta (5.20 +- 5.20) |   8.00* |       10.91**
## Confidence_Fake |     AI_Danger | -0.17 | [-0.36,  0.00] |   96.47% | Beta (5.20 +- 5.20) |    1.61 |          1.01
## n_Real          |     AI_Danger |  0.17 | [-0.01,  0.35] |   96.53% | Beta (5.20 +- 5.20) |    1.49 |         0.943
## 
## Observations: 100

Figures

fig1a <- (rez_at$p +
  theme(axis.text.x = element_blank()) +
  labs(x = "Attractiveness") |
  rez_gl$p +
    labs(x = "Beauty") +
    theme(
      axis.text.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
) /
  (rez_tr$p +
    labs(x = "Trustworthiness") |
    rez_fa$p +
      labs(x = "Familiarity") +
      theme(
        axis.text.y = element_blank(),
        axis.title.y = element_blank()
      )
  ) +
  plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
  plot_layout(guides = "collect") &
  theme(legend.position='top', legend.title = element_blank())

fig <- wrap_elements(fig1a) /
  wrap_elements(
    ((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) + 
  plot_layout(guides = "collect") +
  plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
  ) +
  plot_layout(heights = c(1.1, 0.9))

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
  param <- cor_test(dfsub, x, y, bayesian = TRUE)

  # Format stat output
  r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
  CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
  CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")

  stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")

  label <- data.frame(
    x = min(dfsub[[x]], na.rm = TRUE),
    y = max(dfsub[[y]], na.rm = TRUE),
    label = stat
  )

  # Plot
  dfsub |>
    ggplot(aes_string(x = x, y = y)) +
    geom_point2(
      size = 3,
      color = fillx,
      # color = DVs[x],
      alpha = 2 / 3
    ) +
    geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
    labs(y = ylab, x = xlab) +
    geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fillx, color = "white") +
    ggside::geom_ysidedensity(fill = fill, color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))
}

p1 <- plot_correlation(dfsub,
  x = "IPIP6_HonestyHumility",
  y = "Confidence_Real",
  ylab = "Confidence that the stimulus is real",
  xlab = "Honesty-Humility",
  fillx = "#00BCD4",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p2 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p3 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is real",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p4 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p5 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p6 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_GrandioseFantasies",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Grandiose Fantasies)",
  fillx = "#FFC107",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

fig <- wrap_elements(fig1a) /
  wrap_elements(
    ((p3 / p2) | (p1 / p6) | (p4 / p5)) + 
  plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
  ) +
  plot_layout(heights = c(1.1, 0.9))

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)

References